TeX 1995 July/TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO/macros/latex209/contrib/textyl/psrc/textyl.pas.ah

Text File | 1993-11-07 | 27KB | 874 lines

     strcopy (dvifname.str, logfilnam.str, dvifname.len);
     logfilnam.len := dvifname.len;
     rp := revindex (logfilnam, '.');
     (* add a ".tlog" extension *)
     i := rp - 1;
     logfilnam.str[i + 1] := '.';
     logfilnam.str[i + 2] := 't';
     logfilnam.str[i + 3] := 'l';
     logfilnam.str[i + 4] := 'o';
     logfilnam.str[i + 5] := 'g';
     logfilnam.len := i + 5;

     openlogfile;
end;


{-----------------------------------------------------}
    function inTFM (z: integer): boolean;
    label
        9997, 9998, 9999;
    var
        k: integer;
        lh: integer;
        nw: integer;
        alpha, beta: integer;
    begin
        readtfmword;
        lh := b2 * 256 + b3;
        readtfmword;
        font[nf].bc := b0 * 256 + b1;
        font[nf].ec := b2 * 256 + b3;
        if (font[nf].ec < font[nf].bc) then
            font[nf].bc := font[nf].ec + 1;
        readtfmword;
        nw := b0 * 256 + b1;
        if ((nw = 0) or (nw > 256)) then
            goto 9997;
        for k := 1 to 3 + lh do
          begin
            if eof(tfmfile) then
                goto 9997;
            readtfmword;
            if (k = 4) then
              if (b0 < 128) then
                tfmchecksum := ((b0 * 256 + b1) * 256 + b2) * 256 + b3
              else
                tfmchecksum := (((b0 - 256) * 256 + b1) * 256 + b2) * 256 + b3
          end;

            for k := 0 to (font[nf].ec - font[nf].bc) do
              begin
                readtfmword;
                if (b0 > nw) then
                    goto 9997;
                font[nf].widths[k] := b0
              end;
          alpha := 16 * z;
          beta := 16;
          while z >= TWO23 do
            begin
              z := z div 2;
              beta := beta div 2
            end;
        for k := 0 to nw - 1 do
          begin
            readtfmword;
            inwidth[k] := (((b3 * z) div 256 + b2 * z) div 256 + b1 * z) div beta;
            if b0 > 0 then
                if b0 < 255 then
                    goto 9997
                else
                    inwidth[k] := inwidth[k] - alpha;
          end;
        if inwidth[0] <> 0 then
            goto 9997;
        with font[nf] do
          begin
          for k := 0 to (ec - bc) do
            if widths[k] = 0 then
              begin
              widths[k + bc] := TWO31;
{              pixelwidths[k + bc] := 0;}
              end
            else
              begin
              widths[k + bc] := inwidth[widths[k]];
{              pixelwidths[k + bc] := round(conv * widths[k]);}
              end;
           end; (* with *)
        inTFM := true;
        goto 9999;
9997:
    complain (ERRREALBAD);
        writestrng(tfmname,true);
    writeln(logfile,'---not loaded, TFM file is bad');

9998:
        inTFM := false;
9999:

    end;



{-----------------------------------------------------}
procedure Fastdefinefont (fn: integer);
var     p, k: integer;
        n, waste: integer;
        c, q, d: integer;

begin  { Fastdefinefont }
  c := Dsign4byte;
  q := Dsign4byte;
  d := Dsign4byte;
  p := Dget1byte;
  n := Dget1byte;
  for k := 1 to (p + n) do
    waste := Dget1byte;
end;  { Fastdefinefont }


{-----------------------------------------------------}
    procedure definefont (e: integer);
    var
        f: 0..MAXFONTS;
        p, k: integer;
        n: integer;
        c, q, d: integer;
        r: integer;
    begin
        if (nf = MAXFONTS) then
        begin
      complain (ERRREALBAD);
          writeln(logfile,'TeXtyl capacity exceeded (max fonts=', MAXFONTS: 1, ')!');
          writeln('TeXtyl capacity exceeded (max fonts=', MAXFONTS: 1, ')!');
          jumpout
        end;
        font[nf].num := e;
        f := 0;
        while font[f].num <> e do  (* find first occurrence *)
            f := f + 1;
        c := Dsign4byte;
        font[nf].checksum := c;
        q := Dsign4byte;
        font[nf].scaledsize := q;
        d := Dsign4byte;
        font[nf].designsize := d;
        p := Dget1byte;
        n := Dget1byte;
        font[nf].name.len := p + n;
        for k := 1 to (p + n) do
           font[nf].name.str[k] := Dget1byte;

        if (f = nf) then
        begin (* f = nf *)
            for k := 1 to AREALENGTH do
                tfmname.str[k] := ' ';

              r := 0;

            for k := 1 to font[nf].name.len do
              begin
                r := r + 1;
                tfmname.str[r] := xchr[font[nf].name.str[k]]
              end;
            tfmname.str[r + 1] := '.';
            tfmname.str[r + 2] := 't';
            tfmname.str[r + 3] := 'f';
            tfmname.str[r + 4] := 'm';

        tfmname.str[r + 5] := chr(32);

        tfmname.len := r + 4;

            if (not opentfmfile) then
          begin
            complain (ERRREALBAD);
                writestrng(tfmname,true);
        writeln(logfile,'---not loaded, TFM file can''t be opened!');
        writestrng(tfmname, false);
        writeln(' cannot be opened. Aborting.');
        jumpout;
             end
            else
              begin
                if (q <= 0) or (q >= TWO27) then
          begin
            complain (ERRREALBAD);
                    writestrng(tfmname,true);
                    writeln(logfile,'---not loaded, bad scale (', q: 1, ')!');
          end
                else if (d <= 0) or (d >= TWO27) then
          begin
            complain (ERRREALBAD);
                    writestrng(tfmname,true);
                    writeln(logfile,'---not loaded, bad design size (', d: 1, ')!');
          end
                else
                  if inTFM(q) then
                    begin (* intfm *)
                    font[nf].space := q div 6;
                    if (c <> 0) and (tfmchecksum <> 0) and (c <> tfmchecksum) then
                      begin
                      writeln(logfile,'Problem in fig#',pgfigurenum:0,' on page ',currpagenum:0);
                  writestrng(tfmname,true);
                      writeln(logfile,'---beware: check sums do not agree!');
                      writeln(logfile,'   (', c: 1, ' vs. ', tfmchecksum: 1, ')');
                      end;
                    d := round(100.0 * conv * q / (trueconv * d));
                    nf := nf + 1;
                    font[nf].space := 0;
                    end (* intfm *)
                 end;
            end;
    end;

{-----------------------------------------------------}
    function firstpar (o: OctByt): integer;
    var fpar : integer;
    begin
       case (o) of
            0, 1, 2, 3, 4, 5, 6,
            7, 8, 9, 10, 11, 12, 13,
            14, 15, 16, 17, 18, 19, 20,
            21, 22, 23, 24, 25, 26, 27,
            28, 29, 30, 31, 32, 33, 34,
            35, 36, 37, 38, 39, 40, 41,
            42, 43, 44, 45, 46, 47, 48,
            49, 50, 51, 52, 53, 54, 55,
            56, 57, 58, 59, 60, 61, 62,
            63, 64, 65, 66, 67, 68, 69,
            70, 71, 72, 73, 74, 75, 76,
            77, 78, 79, 80, 81, 82, 83,
            84, 85, 86, 87, 88, 89, 90,
            91, 92, 93, 94, 95, 96, 97,
            98, 99, 100, 101, 102, 103, 104,
            105, 106, 107, 108, 109, 110, 111,
            112, 113, 114, 115, 116, 117, 118,
            119, 120, 121, 122, 123, 124, 125,
            126, 127:
                fpar := o - 0;
            128, 133, 235, 239, 243:
                fpar := Dget1byte;
            129, 134, 236, 240, 244:
                fpar := Dget2byte;
            130, 135, 237, 241, 245:
                fpar := Dget3byte;
            143, 148, 153, 157, 162, 167:
                fpar := Dsign1byte;
            144, 149, 154, 158, 163, 168:
                fpar := Dsign2byte;
            145, 150, 155, 159, 164, 169:
                fpar := Dsign3byte;
            131, 132, 136, 137, 146, 151, 156,
            160, 165, 170, 238, 242, 246:
                fpar := Dsign4byte;
            138, 139, 140, 141, 142, 247, 248,
            249, 250, 251, 252, 253, 254, 255:
                fpar := 0;
            147:
                fpar := w;
            152:
                fpar := x;
            161:
                fpar := y;
            166:
                fpar := z;
            171, 172, 173, 174, 175, 176, 177,
            178, 179, 180, 181, 182, 183, 184,
            185, 186, 187, 188, 189, 190, 191,
            192, 193, 194, 195, 196, 197, 198,
            199, 200, 201, 202, 203, 204, 205,
            206, 207, 208, 209, 210, 211, 212,
            213, 214, 215, 216, 217, 218, 219,
            220, 221, 222, 223, 224, 225, 226,
            227, 228, 229, 230, 231, 232, 233,
            234:
                fpar := o - 171
        end;
        firstpar := fpar;
    end;

{-----------------------------------------------------}
    function specialcases (o: OctByt; p: integer): boolean;
    label
        46, 44, 30, 9998;
    var
        pure: boolean;

    begin
        pure := true;
        if ((o < 157) or (o > 249)) then
          begin
        complain (ERRREALBAD);
            writeln(logfile, 'undefined command ', o: 1, '!');
            goto 30;
          end;
        case (o) of
            157, 158, 159, 160:
                begin
                    goto 44;
                end;
            161, 162, 163, 164, 165:
                begin
                    y := p;
                    goto 44;
                end;
            166, 167, 168, 169, 170:
                begin
                    z := p;
                    goto 44;
                end;
            171, 172, 173, 174, 175, 176, 177,
            178, 179, 180, 181, 182, 183, 184,
            185, 186, 187, 188, 189, 190, 191,
            192, 193, 194, 195, 196, 197, 198,
            199, 200, 201, 202, 203, 204, 205,
            206, 207, 208, 209, 210, 211, 212,
            213, 214, 215, 216, 217, 218, 219,
            220, 221, 222, 223, 224, 225, 226,
            227, 228, 229, 230, 231, 232, 233,
            234:
                begin
                    goto 46;
                end;
            235, 236, 237, 238:
                begin
                    goto 46;
                end;
            243, 244, 245, 246:
                begin
                    definefont(p);
                    goto 30;
                end;

            239, 240, 241, 242:
                begin   (* =========specials============= *)
                  mainhandlespecials (o, p);
                  goto 30;
                end;
            247:
                begin
          complain (ERRREALBAD);
                  writeln(logfile,'preamble command within a page!');
                  goto 9998;
                end;
            248, 249:
                begin
          complain (ERRREALBAD);
                  writeln(logfile,'postamble command within a page!');
                  goto 9998;
                end;
       (*     others:
                begin
                  write(' ', 'undefined command ', o: 1, '!');
                  goto 30;
                end
    *)
        end;
44:  (* label *)
        if (v > 0) and (p > 0) then
            if (v > TWO31 - p) then
            begin
                p := TWO31 - v
            end;
        if (v < 0) and (p < 0) then
            if ((-v) > (p + TWO31)) then
            begin
                p := -v - TWO31
            end;

        v := v + p;

        goto 30;
46:  (* label *)
        font[nf].num := p;
        curfont := 0;
        while font[curfont].num <> p do
            curfont := curfont + 1;
        goto 30 ;
9998:
        pure := false;
30:
        specialcases := pure;
    end;


{-----------------------------------------------------}
    function dopage : boolean;
    label
        41, 42, 43, 30, 9998, 9999;
    var
        o: OctByt;
        p, q: integer;

    begin
        curfont := nf;
     s := 0;
        h := 0;
        v := 0;
        w := 0;
        x := 0;
        y := 0;
        z := 0;

        ourxpos := 0;
    ourypos := 0;
    ourfontnum := (-1);
        while true do
          begin
            o := Dget1byte;
            p := firstpar(o);
            if eof(dvifile) then begin
                writeln(logfile, 'Bad DVI file: ', 'the file ended prematurely', '!');
                writeln('Bad DVI file: ', 'the file ended prematurely', '!');
                jumpout
            end;
            if o <= 131 then
              begin
                goto 41;
              end
            else
              begin
               if (o > 156) then
                 begin
                   if specialcases(o, p) then
                      goto 30
                   else
                      goto 9998;
                 end;

                case (o) of
                    133, 134, 135, 136:
                        begin
                          goto 41;
                        end;
                    132, 137:
                        begin
                            goto 42
                        end;
                    138:
                        begin
                            goto 30;
                        end;
                    139:
                        begin (* BOP *)
              complain (ERRREALBAD);
                          writeln(logfile, 'bop occurred before eop');
                          goto 9998; (* Fail *)
                        end;
                    140:
                        begin (* EOP *)
                            if (s <> 0) then
                  begin
                  complain (ERRREALBAD);
                              writeln(logfile, 'stack not empty at end of page (level ', s: 1, ')!');
                  end;
                if (multifigure <> 0) then
                  begin
                    complain (ERRBAD);
                    writeln(logfile,'Some figure definition not closed at end of page ', currpagenum:0,'!');
                  end;

                            write (currpagenum:0,']');
                            write (logfile,currpagenum:0,']');
                if ((currpagenum mod 10) = 0) then
                  writeln;
                            dopage := true;
                            goto 9999;
                        end;
                    141:
                        begin (* PUSH *)
                          with stack[s] do
                            begin
                            sh := h;
                            sv := v;
                            sw := w;
                            sx := x;
                            sy := y;
                            sz := z;
                            end; (* with *)
                          s := s + 1;
                          goto 30;
                        end;
                    142:
                        begin (* POP *)
                            if s = 0 then
                  begin
                  complain (ERRREALBAD);
                              writeln(logfile,'illegal pop at level zero!');
                  end
                            else
                  begin
                                s := s - 1;
                                with stack[s] do
                                  begin
                                  h := sh;
                                  v := sv;
                                  w := sw;
                                  x := sx;
                                  y := sy;
                                  z := sz;
                                  end;
                               end;
                            goto 30;
                        end;
                    143, 144, 145, 146:
                        begin
                            q := p;
                            goto 43
                        end;
                    147, 148, 149, 150, 151:
                        begin
                            w := p;
                            q := p;
                            goto 43
                        end;
                    152, 153, 154, 155, 156:
                        begin
                            x := p;
                            q := p;
                            goto 43
                        end;
                (*    others:
                        if specialcases(o, p) then
                            goto 30
                        else
                            goto 9998;
                                *)
                end; (* case *)
            end; (* else *)
41:   (* finish cmd to set/put a char *)
            if p < 0 then
                p := 255 - (-1 - p) mod 256
            else if p >= 256 then
                p := p mod 256;
            if (p < font[curfont].bc) or (p > font[curfont].ec) then
                q := TWO31
            else
                q := font[curfont].widths[p];
            if (q = TWO31) then
              begin
            complain (ERRREALBAD);
                writeln(logfile,'Character ', p:1,' invalid in font #',curfont:0);
              end;
            if o >= 133 then
                goto 30;
            if q = TWO31 then
                q := 0;
            goto 43;

42:  (* finish cmd to set/put rule *)
            q := Dsign4byte;
            if o = 137 then
                goto 30;
            goto 43 ;

43:  (*finish cmd that sets h += q *)
            if (h > 0) and (q > 0) then
                if (h > (TWO31 - q)) then
                  begin
                    q := TWO31 - h
                  end;
            if (h < 0) and (q < 0) then
                if ((-h) > (q + TWO31)) then
                  begin
                    q := (-h) - TWO31
                  end;

            h := h + q;
30:
        end;
9998:
        dopage := false;
9999:

    end;

{-----------------------------------------------------}
    procedure skippages;
    label
        9999;
    var
        p: integer;
        k: 0..255;
        downthedrain: integer;
    begin
        while true do
          begin
            if eof(dvifile) then
              begin
                writeln(logfile, 'Bad DVI file: ', 'the file ended prematurely', '!');
                write(' ', 'Bad DVI file: ', 'the file ended prematurely', '!');
                jumpout
              end;
            k := Dget1byte;
            p := firstpar(k);
            case (k) of
                139:
                    begin (* BOP *)
                        newbackptr := DVIMark + TotBytesWritten - 1;
            currpagenum := Dsign4byte; (* count[0] *)
                        for k := 1 to 9 do
                            waste := Dsign4byte; (* WAS count[k] := *)
                        downthedrain := Dsign4byte;
                        BackupInBuf (4);
                        cmdSigned (oldbackptr, 4);
                        oldbackptr := newbackptr;
                        write(' [');
                        write(logfile,' [');
                        goto 9999;
                    end;
                132, 137: (* RULE *)
                    downthedrain := Dsign4byte;
                243, 244, 245, 246:
                    begin
                        definefont(p);
                    end;
                239, 240, 241, 242: (* specials *)
                    begin
                        mainhandlespecials (k, p);
                    end;
                248:
                    begin (* POST *)
                        ourq := DVIMark + TotBytesWritten - 1;
                        inpostamble := true;
                        goto 9999
                    end;
              (*  others:
                    null
        *)
            end
        end;
    9999:

    end;

{-----------------------------------------------------}
    procedure readpostamble;
    var
        k: integer;
        p, q, m: integer;
        indx : integer;
    begin
        if (Dsign4byte <> numerator) then
            writeln(logfile,'Postamble',' numerator',' doesn''t match the preamble!');
        if (Dsign4byte <> denominator) then
            writeln(logfile,'Postamble',' denominator',' doesn''t match the preamble!');
        if (Dsign4byte <> mag) then
           begin
           writeln(logfile,'Postamble',' magnification',' doesn''t match the preamble!');
           end;
        maxv := Dsign4byte;
        maxh := Dsign4byte;
        maxs := Dget2byte;
        BackupInBuf (2);
        cmd2byte (maxs + 2); (* pretend the stack depth
                  * does not increase by
                  * more than two
                  *)

        totalpages := Dget2byte;
        repeat
            k := Dget1byte;
            if (k >= 243) and (k < 247) then
              begin
                p := firstpar(k);
                Fastdefinefont(p);
                k := 138;
              end
        until k <> 138; (* NOP *)

       (* here, backup 1, enter all our fonts and
        then output the 249 that we backed over *)
        BackupInBuf (1);
        for indx := 1 to MFontsDefd do
          begin
          with MFontTable[indx]^ do
            enterfont (DVIFontNum, Cksum, DesSize,
                       DesSize, FontName );
          end; (* for *)
        for indx := 1 to VFontsDefd do
          begin
          with VFontTable[indx]^ do
            enterfont (DVIFontNum, Cksum, DesSize,
                        DesSize, FontName);
          end;  (* for *)
    for indx := 1 to LFontsDefd do
      begin
      with LFontTable[indx]^ do
        enterfont (DVIFontNum, Cksum, DesSize,
                DesSize, FontName);
      end;
        cmd1byte(249);  (* post post *)

        if (k <> 249) then
            writeln(logfile,'byte ',k:0,' is not postpost!');
        q := Dsign4byte;
        BackupInBuf (4);
        cmd4byte (ourq);
        m := Dget1byte;
        if (m <> 2) then
            writeln(logfile,'identification should be ', 2: 1, '!');
        m := 223;
        while (m = 223) and not eof(dvifile) do
            m := Dget1byte;
        if not eof(dvifile) then
    begin
            writeln(' ', 'Bad DVI file: ', 'signature in should be 223', '!');
            writeln(logfile, 'Bad DVI file: ', 'signature in should be 223', '!');
            jumpout
        end;
    end;


(* MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN MAIN *)
begin (* main *)
    initialize;
    AskandOpenFiles;  (* ask for filenames of inputdvi and outputfil *)

    writeln(logfile, TylVersion,' for Berkeley Unix');

    write(logfile,'Reading File: ');
    writestrng(dvifname,true);
    writeln(logfile);


    p := Dget1byte;
    if (p <> 247) then
    begin
        write(' ', 'Bad DVI file: ', 'First byte isn''t start of preamble!', '!');
        writeln(logfile,'Bad DVI file: ', 'First byte isn''t start of preamble!', '!');
        jumpout
    end;
    p := Dget1byte;
    if (p <> 2) then
        writeln(logfile,'identification in byte 1 should be ', 2: 1, '!');
    numerator := Dsign4byte;
    denominator := Dsign4byte;
    if (numerator <= 0) then
    begin
        write(' ', 'Bad DVI file: ', 'numerator is ', numerator: 1, '!');
        writeln(logfile, 'Bad DVI file: ', 'numerator is ', numerator: 1, '!');
        jumpout
    end;
    if (denominator <= 0) then
    begin
        write(' ', 'Bad DVI file: ', 'denominator is ', denominator: 1, '!');
        writeln(logfile, 'Bad DVI file: ', 'denominator is ', denominator: 1, '!');
        jumpout
    end;
    conv := numerator / 254000.0 * (resolution / denominator);
    mag := Dsign4byte;
    if (mag <= 0) then
    begin
        write(' ', 'Bad DVI file: ', 'magnification is ', mag: 1, '!');
        writeln(logfile, 'Bad DVI file: ', 'magnification is ', mag: 1, '!');
        jumpout
    end;
    magfactor := mag / 1000.0;
    trueconv := conv;
    conv := trueconv * magfactor;
    p := Dget1byte;     (* the 'k' of the preamble *)
    while p > 0 do
    begin
        p := p - 1;
        waste := Dget1byte;
    end;

    skippages;
    if not inpostamble then
    begin
        while (maxpages > 0) do
          begin (* while *)
            maxpages := maxpages - 1;
            if (not dopage) then
              begin
                write(' ', 'Bad DVI file: ', 'page ended unexpectedly', '!');
                writeln(logfile, 'Bad DVI file: ', 'page ended unexpectedly', '!');
                jumpout
              end;
        (* now we are at an EOP ---end of page *)
        (*  flushout GDVIbuffer, and reset counters *)
{         writeln('EOP: bytes used= ',GDVIBuf.TotByteLen:0);  }
            WriteDVIBuf;
            ClearDVIBuf;
            multifigure := 0;
        pgfigurenum := 0;
            FTBDs := 0;
            didnewfonts := false;
            repeat
                k := Dget1byte;
                if (k >= 243) and (k < 247) then
                  begin (* fontdefs *)
                    p := firstpar(k);
                    definefont(p);
                    k := 138
                  end;
            until (k <> 138); (* nop *)

            if (k = 248) then
            begin
                inpostamble := true;
                ourq := DVIMark + TotBytesWritten - 1;
                goto 30
            end;

            if (k = 139) then  (* BOP *)
            begin
        newbackptr := DVIMark + TotBytesWritten - 1;
        currpagenum := Dsign4byte; (* Count[0] *)
        for k := 1 to 9 do
            waste := Dsign4byte; (* WAS count[k] := *)
        waste := Dsign4byte; (* backpointer *)
        BackupInBuf (4);
        cmdSigned (oldbackptr, 4);
        oldbackptr := newbackptr;
        write(' [');
        write(logfile,' [');
          end
        else
              begin (* NOT bop?? *)
        writeln('We did not find BOP when expected');
        writeln(logfile,'We did not find BOP when expected');
                jumpout;
              end;

        end; (* while *)
30:
    end; (* if not inpostamble *)
    if (not inpostamble) then
    skippages;
    waste := Dsign4byte; (* ptr to the last bop in file *)
    BackupInBuf (4);
    cmdSigned (oldbackptr, 4);
    readpostamble;
    WriteDVIBuf;

    while ((TotBytesWritten mod 4) <> 0) do
       OutputByte(223);  (* final signatures *)

    writeln;
    writeln(logfile);
    write ('Output written on ');
    writestrng(outname, false);
    write(' (',currpagenum:0,' page');
    if (currpagenum > 1) then
      write('s');
    writeln(', ',TotBytesWritten:0,' bytes).');

    write (logfile,'Output written on ');
    writestrng(outname, true);
    write(logfile,' (',currpagenum:0,' page');
    if (currpagenum > 1) then
      write(logfile,'s');
    writeln(logfile,', ',TotBytesWritten:0,' bytes).');

    write ('Log written on ');
    writestrng(logfilnam, false); writeln;
    write (logfile,'Log written on ');
    writestrng(logfilnam, true); writeln (logfile);
    writeln;
    writeln(logfile);
666:
    if (ErrorOccurred) then
      begin
        writeln;
        writeln('Some error(s) occurred. Please check Logfile for details');
        writeln('Assume that the outputfile is incorrect');
      end;
end.